home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_pcdp / adas / compile.pas < prev    next >
Pascal/Delphi Source File  |  1996-01-30  |  12KB  |  449 lines
  1. unit compile;
  2.  
  3.   { Main program for compiler }
  4.  
  5. interface
  6. uses global, util, state;
  7. procedure compiler(var result: boolean);
  8.  
  9. implementation
  10.  
  11. procedure block(level: integer);
  12.  
  13.   { Compile a block -
  14.      all routines except initialization are local to block }
  15. type
  16.   conrec =    { constant record }
  17.     record
  18.       tp: types;   { constant type }
  19.       i:  integer  { constant value }
  20.     end;
  21.  
  22. var dx:  integer;  { counter for stack memory requirements }
  23.     prt: integer;  { symbol table pointer for this block }
  24.     prb: integer;  { block table pointer for this block }
  25.  
  26. procedure constant(var c: conrec);
  27.   { Constant declaration:
  28.       character or integer constants,
  29.       also equate one constant to another.
  30.     Called from variable declaration in Ada }
  31. var x, sign: integer;
  32. begin
  33.   c.tp := notyp;
  34.   c.i := 0;
  35.   if sy in constbegsys then
  36.     if sy = charcon then
  37.       begin
  38.       c.tp := chars;
  39.       c.i := inum;
  40.       insymbol
  41.       end
  42.     else begin
  43.       sign := 1;
  44.       if sy in [plus, minus] then
  45.         begin
  46.         if sy = minus then sign := -1;
  47.         insymbol
  48.         end;
  49.       if sy = ident then
  50.         begin
  51.         x := loc(level, id);
  52.         if x = 0 then error(ernf);
  53.         if tab[x].obj <> konstant then error(ertyp);
  54.         c.tp := tab[x].typ;
  55.         c.i := sign * tab[x].adr;
  56.         insymbol
  57.         end
  58.       else if sy = intcon then
  59.         begin
  60.         c.tp := ints;
  61.         c.i := sign * inum;
  62.         insymbol
  63.         end
  64.       else error(erkey)
  65.       end
  66. end;
  67.  
  68. procedure typ(var tp: types; var rf, sz: integer);
  69.   { Compilation of "subtype indication":
  70.       Only allowed to equate to an existing type and
  71.       to define a one dimensional array}
  72. var x: integer;
  73.     eltp: types;
  74.     elrf: integer;
  75.     elsz, offset, t0, t1: integer;
  76.  
  77.   procedure arraytyp(var aref, arsz: integer);
  78.   var eltp: types;
  79.       low, high: conrec;
  80.       elrf, elsz: integer;
  81.   begin
  82.     constant(low);
  83.     if sy = colon then insymbol else error(erpun);
  84.     constant(high);
  85.     if high.tp <> low.tp then error(ertyp);
  86.     enterarray(low.tp, low.i, high.i);
  87.     aref := a;
  88.     if sy = rparent then insymbol else error(erpun);
  89.     if sy = ofsy then insymbol else error(erkey);
  90.     typ(eltp, elrf, elsz);
  91.     with atab[aref] do
  92.       begin
  93.       arsz := (high-low+1) * elsz;
  94.       size := arsz;
  95.       eltyp := eltp;
  96.       elsize := elsz
  97.       end
  98.   end;
  99.  
  100. begin (* typ *)
  101.   tp := notyp;
  102.   rf := 0;
  103.   sz := 0;
  104.   if sy in typebegsys then
  105.     if sy = ident then
  106.       begin
  107.       x := loc(level, id);
  108.       if x = 0 then error(ernf);
  109.       with tab[x] do begin
  110.         if obj <> type1 then error(ertyp);
  111.         tp := typ;
  112.         rf := ref;
  113.         sz := adr;
  114.         if tp = notyp then error(ertyp)
  115.         end;
  116.       insymbol
  117.       end
  118.     else if sy = arraysy then
  119.       begin
  120.       insymbol;
  121.       if sy = lparent then insymbol else error(erpun);
  122.       tp := arrays;
  123.       arraytyp(rf, sz)
  124.       end
  125.     else error(erkey)
  126. end;
  127.  
  128. procedure parameterlist;
  129.   { Parameter list declarations:
  130.        in parameter like Pascal value copy semantics
  131.        out and in out parameter like Pascal var reference semantics }
  132. var tp: types;
  133.     rf, x, t0: integer;
  134.     valpar: boolean;
  135. begin
  136.   insymbol;
  137.   tp := notyp;
  138.   rf := 0;
  139.   while sy = ident do
  140.     begin
  141.     valpar := true;
  142.     t0 := t;
  143.     repeat
  144.       enter(id, variable, level);
  145.       insymbol;
  146.       if sy = comma then insymbol
  147.     until sy <> ident;
  148.     if sy = colon then insymbol else error(erpun);
  149.     if sy = insy then insymbol;
  150.     if sy = outsy then
  151.       begin valpar := false; insymbol end;
  152.     if sy <> ident then error(erid);
  153.     x := loc(level, id);
  154.     insymbol;
  155.     if x = 0 then error(ernf);
  156.     with tab[x] do begin
  157.       if obj <> type1 then error(ertyp);
  158.       tp := typ;
  159.       rf := ref;
  160.       if valpar and (typ=arrays) then error(ertyp)
  161.       end;
  162.     while t0 < t do
  163.       begin
  164.       t0 := t0 + 1;
  165.       with tab[t0] do
  166.         begin
  167.         typ := tp;
  168.         ref := rf;
  169.         normal := valpar;
  170.         adr := dx;
  171.         lev := level;
  172.         dx := dx + 1
  173.         end
  174.       end;
  175.     if sy <> rparent then
  176.       if sy = semicolon then insymbol else error(erpun);
  177.     end (* while *);
  178.   if sy = rparent then insymbol else error(erpun)
  179. end;
  180.  
  181. procedure typedeclaration;
  182. var tp: types;
  183.     rf, sz, t1: integer;
  184. begin
  185.   insymbol;
  186.   enter(id, type1, level);
  187.   t1 := t;
  188.   insymbol;
  189.   if sy = issy then insymbol else error(erpun);
  190.   typ(tp, rf, sz);
  191.   with tab[t1] do
  192.     begin
  193.     typ := tp;
  194.     ref := rf;
  195.     adr := sz
  196.     end;
  197.   if sy = semicolon then insymbol else error(erpun)
  198. end;
  199.  
  200. procedure variabledeclaration;
  201.   { Variable declaration:
  202.       includes Ada constant declarations,
  203.       initial values are noted in a special table which
  204.         causes code to be emitted upon entry to the program }
  205. var t0, t1, rf, sz: integer;
  206.     tp: types;
  207.     c: conrec;
  208.     cflag, initflag: boolean;
  209. begin
  210.   while sy = ident do
  211.     begin
  212.     cflag := false;
  213.     initflag := false;
  214.     t0 := t;
  215.     repeat
  216.       enter(id, variable, level);
  217.       insymbol;
  218.       if sy = comma then insymbol
  219.     until sy <> ident;
  220.     if sy = colon then insymbol else error(erpun);
  221.     if sy = constsy then   { note that this is a constant }
  222.       begin
  223.       insymbol;
  224.       cflag := true
  225.       end;
  226.     t1 := t;
  227.     if sy = becomes then tp := ints
  228.     else typ(tp, rf, sz);
  229.     if sy = becomes then  { either initial value or constant }
  230.       begin
  231.       insymbol;
  232.       if (sy = ident) and (id = 'init      ') then
  233.         begin  { special form for semaphore initialization }
  234.         insymbol;
  235.         if sy = lparent then insymbol else error(erpun);
  236.         constant(c);
  237.         if sy = rparent then insymbol else error(erpun)
  238.         end
  239.       else constant(c);
  240.       initflag := true;
  241.       if c.tp <> tp then error(ertyp)
  242.       end;
  243.     while t0 < t1 do
  244.       begin
  245.       t0 := t0 + 1;
  246.       with tab[t0] do
  247.         if cflag then  { constant must be initialized }
  248.           if not initflag then error(erkey)
  249.           else begin
  250.             typ := c.tp;
  251.             adr := c.i;
  252.             ref := 0;
  253.             obj := konstant
  254.           end
  255.       else begin
  256.         typ := tp;
  257.         ref := rf;
  258.         lev := level;
  259.         adr := dx;
  260.         normal := true;
  261.         dx := dx + sz;
  262.         if initflag then  { store info on initialization }
  263.           begin
  264.           if c.tp <> typ then error(ertyp);
  265.           inits := inits + 1;
  266.           inittab[inits].addr := adr;
  267.           inittab[inits].value := c.i
  268.           end
  269.         end
  270.     end;
  271.     if sy = semicolon then insymbol else error(erpun)
  272.     end
  273. end;
  274.  
  275. procedure procdeclaration;
  276.   { Procedure declaration - also used for tasks }
  277. var istask: boolean;
  278.     id1: alfa;
  279. begin
  280.   istask := sy = tasksy;
  281.   if sy = tasksy then  { ignore task specification !! }
  282.     repeat insymbol until sy = bodysy;
  283.   insymbol;
  284.   if sy <> ident then error(erid);
  285.   id1 := id;   { save name to check at end }
  286.   if istask then enter(id, task, level)
  287.             else enter(id, prozedure, level);
  288.   if istask then curtask := t;
  289.   tab[t].normal := true;
  290.   if istask then  { tasks must be elaborated }
  291.     begin
  292.     elabs := elabs + 1;
  293.     elabtab[elabs] := loc(level, id)
  294.     end;
  295.   insymbol;
  296.   block(level+1);
  297.   if sy = ident then
  298.     begin
  299.     if id <> id1 then error(erkey);
  300.     insymbol
  301.     end;
  302.   if sy = semicolon then insymbol else error(erpun);
  303.   emit(32)  (* exit *)
  304. end;
  305.  
  306. procedure initouterblock;
  307.   { Outermost block emits code for initializing global variables
  308.       and elaborating tasks }
  309. var x: integer;
  310. begin
  311.   for x := 1 to inits do
  312.     begin
  313.     emit2(0,1,inittab[x].addr);  { load variable address }
  314.     emit1(24,inittab[x].value);  { load initial value }
  315.     emit1(38,0)                  { store }
  316.     end;
  317.   if elabs <> 0 then
  318.     begin
  319.     emit(4);                     { cobegin from Pascal-S }
  320.     for x := 1 to elabs do
  321.       begin
  322.       emit1(18, elabtab[x]);     { markstack and call task }
  323.       emit1(19, btab[tab[elabtab[x]].ref].psize-1)
  324.       end;
  325.     emit(5)                      { coend from Pascal-S }
  326.     end
  327. end;
  328.  
  329. begin (* block *)
  330.   dx := 5;
  331.   prt := t;
  332.   if level > lmax then fatal(5);
  333.   enterblock;
  334.   display[level] := b;
  335.   prb := b;
  336.   tab[prt].typ := notyp;
  337.   tab[prt].ref := prb;
  338.   if (sy = lparent) and (level > 1) then parameterlist;
  339.   btab[prb].lastpar := t;
  340.   btab[prb].psize := dx;
  341.   if sy = issy then insymbol else error(erpun);
  342.   repeat     { no predefined order in Ada }
  343.     if sy = typesy then typedeclaration;
  344.     if sy in [proceduresy, tasksy] then procdeclaration;
  345.     if sy <> beginsy then variabledeclaration;
  346.     if sy = pragmasy then  { ignore pragmas }
  347.       begin
  348.       repeat insymbol until sy = semicolon;
  349.       insymbol
  350.       end;
  351.   until sy = beginsy;  { terminate upon begin of statement part }
  352.   btab[prb].vsize := dx;
  353.   tab[prt].adr := lc;
  354.   if level = 1 then initouterblock;
  355.   insymbol;
  356.   statement(dx, level);
  357.   while sy in [semicolon] + statbegsys do
  358.     statement(dx, level);
  359.   if sy = endsy then insymbol else error(erkey);
  360.   btab[prb].vsize := dx;
  361. end;
  362.  
  363. procedure initentries;
  364.   { predefined symbol table entries }
  365. begin
  366.   enterst('          ', variable, notyp, 0); (* sentinel *)
  367.   enterst('false     ', konstant, bools, 0);
  368.   enterst('true      ', konstant, bools, 1);
  369.   enterst('character ', type1,    chars, 1);
  370.   enterst('boolean   ', type1,    bools, 1);
  371.   enterst('integer   ', type1,    ints,  1);
  372.   enterst('semaphore ', type1,    ints,  1);
  373.  
  374.   enterst('get       ', prozedure,notyp,  1);
  375.   enterst('skip_line ', prozedure,notyp,  2);
  376.   enterst('put       ', prozedure,notyp,  3);
  377.   enterst('new_line  ', prozedure,notyp,  4);
  378.   enterst('put_line  ', prozedure,notyp,  4);
  379.   enterst('wait      ', prozedure,notyp,  5);
  380.   enterst('signal    ', prozedure,notyp,  6);
  381.   enterst('          ', prozedure,notyp,  0);
  382. end;
  383.  
  384. procedure initcompiler;
  385. begin
  386.   inits := 0;
  387.   elabs := 0;
  388.   t := -1;
  389.   a := 0;
  390.   b := 1;
  391.   display[0] := 1;
  392.   with btab[1] do
  393.     begin
  394.     lastpar := 1;
  395.     psize := 0;
  396.     vsize := 0
  397.     end;
  398.   entries := 0;
  399.   initutil;
  400. end;
  401.  
  402. procedure compiler(var result: boolean);
  403.   { Prompt for file name and then call compiler }
  404. var ok: boolean;
  405.     ch: char;
  406.     progname: alfa;
  407. begin
  408.   write('Listing (y/n) ');
  409.   readln(ch);
  410.   listing := ch = 'y';
  411. {$I-}
  412.   assign(inp, inputfile+'.ada');
  413.   ok := ioresult = 0;
  414.   reset(inp);
  415.   ok := ok and (ioresult = 0);
  416.   if listing then
  417.     begin
  418.     assign(list, inputfile+'.lis');
  419.     ok := ioresult = 0;
  420.     rewrite(list);
  421.     ok := ok and (ioresult = 0);
  422.     end;
  423. {$I+}
  424.   if not ok then writeln('Can''t open') else
  425.     begin
  426.     initcompiler;
  427.     insymbol;
  428.     while sy <> proceduresy do insymbol;
  429.     insymbol;
  430.     if sy <> ident then error(erid);
  431.     progname := id;
  432.     insymbol;
  433.  
  434.     initentries;
  435.     btab[1].last := t;
  436.     block(1);
  437.     if (sy = ident) and (id = progname) then insymbol;
  438.     if sy <> semicolon then error(erpun);
  439.     if btab[2].vsize > stmax-stkincr*pmax then error(erln);
  440.     emit(31); (* halt *)
  441.     if not eof(inp) then readln(inp);
  442.     if listing then close(list);
  443.     writeln('Compilation OK')
  444.     end;
  445.     result := ok
  446. end;
  447.  
  448. end.
  449.